home *** CD-ROM | disk | FTP | other *** search
/ Chip 2007 January, February, March & April / Chip-Cover-CD-2007-02.iso / Pakiet bezpieczenstwa / mini Pentoo LiveCD 2006.1 / mpentoo-2006.1.iso / livecd.squashfs / usr / share / autoconf / Autom4te / FileUtils.pm < prev    next >
Text File  |  2006-04-25  |  7KB  |  331 lines
  1. # Copyright (C) 2003  Free Software Foundation, Inc.
  2.  
  3. # This program is free software; you can redistribute it and/or modify
  4. # it under the terms of the GNU General Public License as published by
  5. # the Free Software Foundation; either version 2, or (at your option)
  6. # any later version.
  7.  
  8. # This program is distributed in the hope that it will be useful,
  9. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. # GNU General Public License for more details.
  12.  
  13. # You should have received a copy of the GNU General Public License
  14. # along with this program; if not, write to the Free Software
  15. # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  16. # 02111-1307, USA.
  17.  
  18. package Autom4te::FileUtils;
  19.  
  20. =head1 NAME
  21.  
  22. Autom4te::FileUtils - handling files
  23.  
  24. =head1 SYNOPSIS
  25.  
  26.   use Autom4te::FileUtils
  27.  
  28. =head1 DESCRIPTION
  29.  
  30. This perl module provides various general purpose file handling functions.
  31.  
  32. =cut
  33.  
  34. use strict;
  35. use Exporter;
  36. use File::stat;
  37. use IO::File;
  38. use Autom4te::Channels;
  39. use Autom4te::ChannelDefs;
  40.  
  41. use vars qw (@ISA @EXPORT);
  42.  
  43. @ISA = qw (Exporter);
  44. @EXPORT = qw (&contents
  45.           &find_file &mtime
  46.           &update_file &up_to_date_p
  47.           &xsystem &xqx);
  48.  
  49.  
  50. =item C<find_file ($filename, @include)>
  51.  
  52. Return the first path for a C<$filename> in the C<include>s.
  53.  
  54. We match exactly the behavior of GNU M4: first look in the current
  55. directory (which includes the case of absolute file names), and, if
  56. the file is not absolute, just fail.  Otherwise, look in C<@include>.
  57.  
  58. If the file is flagged as optional (ends with C<?>), then return undef
  59. if absent, otherwise exit with error.
  60.  
  61. =cut
  62.  
  63. # $FILENAME
  64. # find_file ($FILENAME, @INCLUDE)
  65. # -------------------------------
  66. sub find_file ($@)
  67. {
  68.   use File::Spec;
  69.  
  70.   my ($filename, @include) = @_;
  71.   my $optional = 0;
  72.  
  73.   $optional = 1
  74.     if $filename =~ s/\?$//;
  75.  
  76.   return File::Spec->canonpath ($filename)
  77.     if -e $filename;
  78.  
  79.   if (File::Spec->file_name_is_absolute ($filename))
  80.     {
  81.       fatal "$filename: no such file or directory"
  82.     unless $optional;
  83.       return undef;
  84.     }
  85.  
  86.   foreach my $path (@include)
  87.     {
  88.       return File::Spec->canonpath (File::Spec->catfile ($path, $filename))
  89.     if -e File::Spec->catfile ($path, $filename)
  90.     }
  91.  
  92.   fatal "$filename: no such file or directory"
  93.     unless $optional;
  94.  
  95.   return undef;
  96. }
  97.  
  98. =item C<mtime ($file)>
  99.  
  100. Return the mtime of C<$file>.  Missing files, or C<-> standing for
  101. C<STDIN> or C<STDOUT> are ``obsolete'', i.e., as old as possible.
  102.  
  103. =cut
  104.  
  105. # $MTIME
  106. # MTIME ($FILE)
  107. # -------------
  108. sub mtime ($)
  109. {
  110.   my ($file) = @_;
  111.  
  112.   return 0
  113.     if $file eq '-' || ! -f $file;
  114.  
  115.   my $stat = stat ($file)
  116.     or fatal "cannot stat $file: $!";
  117.  
  118.   return $stat->mtime;
  119. }
  120.  
  121.  
  122. =item C<update_file ($from, $to)>
  123.  
  124. Rename C<$from> as C<$to>, preserving C<$to> timestamp if it has not
  125. changed.  Recognize C<$to> = C<-> standing for C<STDIN>.  C<$from> is
  126. always removed/renamed.
  127.  
  128. =cut
  129.  
  130. # &update_file ($FROM, $TO)
  131. # -------------------------
  132. sub update_file ($$)
  133. {
  134.   my ($from, $to) = @_;
  135.   my $SIMPLE_BACKUP_SUFFIX = $ENV{'SIMPLE_BACKUP_SUFFIX'} || '~';
  136.   use File::Compare;
  137.   use File::Copy;
  138.  
  139.   if ($to eq '-')
  140.     {
  141.       my $in = new IO::File ("$from");
  142.       my $out = new IO::File (">-");
  143.       while ($_ = $in->getline)
  144.     {
  145.       print $out $_;
  146.     }
  147.       $in->close;
  148.       unlink ($from) || fatal "cannot remove $from: $!";
  149.       return;
  150.     }
  151.  
  152.   if (-f "$to" && compare ("$from", "$to") == 0)
  153.     {
  154.       # File didn't change, so don't update its mod time.
  155.       msg 'note', "`$to' is unchanged";
  156.       unlink ($from)
  157.         or fatal "cannot remove $from: $!";
  158.       return
  159.     }
  160.  
  161.   if (-f "$to")
  162.     {
  163.       # Back up and install the new one.
  164.       move ("$to",  "$to$SIMPLE_BACKUP_SUFFIX")
  165.     or fatal "cannot backup $to: $!";
  166.       move ("$from", "$to")
  167.     or fatal "cannot rename $from as $to: $!";
  168.       msg 'note', "`$to' is updated";
  169.     }
  170.   else
  171.     {
  172.       move ("$from", "$to")
  173.     or fatal "cannot rename $from as $to: $!";
  174.       msg 'note', "`$to' is created";
  175.     }
  176. }
  177.  
  178.  
  179. =item C<up_to_date_p ($file, @dep)>
  180.  
  181. Is C<$file> more recent than C<@dep>?
  182.  
  183. =cut
  184.  
  185. # $BOOLEAN
  186. # &up_to_date_p ($FILE, @DEP)
  187. # ---------------------------
  188. sub up_to_date_p ($@)
  189. {
  190.   my ($file, @dep) = @_;
  191.   my $mtime = mtime ($file);
  192.  
  193.   foreach my $dep (@dep)
  194.     {
  195.       if ($mtime < mtime ($dep))
  196.     {
  197.       verb "up_to_date ($file): outdated: $dep";
  198.       return 0;
  199.     }
  200.     }
  201.  
  202.   verb "up_to_date ($file): up to date";
  203.   return 1;
  204. }
  205.  
  206.  
  207. =item C<handle_exec_errors ($command)>
  208.  
  209. Display an error message for C<$command>, based on the content of
  210. C<$?> and C<$!>.
  211.  
  212. =cut
  213.  
  214. # handle_exec_errors ($COMMAND)
  215. # -----------------------------
  216. sub handle_exec_errors ($)
  217. {
  218.   my ($command) = @_;
  219.  
  220.   $command = (split (' ', $command))[0];
  221.   if ($!)
  222.     {
  223.       fatal "failed to run $command: $!";
  224.     }
  225.   else
  226.     {
  227.       use POSIX qw (WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);
  228.  
  229.       if (WIFEXITED ($?))
  230.     {
  231.       my $status = WEXITSTATUS ($?);
  232.       # Propagate exit codes.
  233.       fatal ('',
  234.          "$command failed with exit status: $status",
  235.          exit_code => $status);
  236.     }
  237.       elsif (WIFSIGNALED ($?))
  238.     {
  239.       my $signal = WTERMSIG ($?);
  240.       fatal "$command terminated by signal: $signal";
  241.     }
  242.       else
  243.     {
  244.       fatal "$command exited abnormally";
  245.     }
  246.     }
  247. }
  248.  
  249. =item C<xqx ($command)>
  250.  
  251. Same as C<qx> (but in scalar context), but fails on errors.
  252.  
  253. =cut
  254.  
  255. # xqx ($COMMAND)
  256. # --------------
  257. sub xqx ($)
  258. {
  259.   my ($command) = @_;
  260.  
  261.   verb "running: $command";
  262.  
  263.   $! = 0;
  264.   my $res = `$command`;
  265.   handle_exec_errors $command
  266.     if $?;
  267.  
  268.   return $res;
  269. }
  270.  
  271.  
  272. =item C<xsystem ($command)>
  273.  
  274. Same as C<system>, but fails on errors, and reports the C<$command>
  275. in verbose mode.
  276.  
  277. =cut
  278.  
  279. # xsystem ($COMMAND)
  280. # ------------------
  281. sub xsystem ($)
  282. {
  283.   my ($command) = @_;
  284.  
  285.   verb "running: $command";
  286.  
  287.   $! = 0;
  288.   handle_exec_errors $command
  289.     if system $command;
  290. }
  291.  
  292.  
  293. =item C<contents ($filename)>
  294.  
  295. Return the contents of c<$filename>.
  296.  
  297. =cut
  298.  
  299. # contents ($FILENAME)
  300. # --------------------
  301. sub contents ($)
  302. {
  303.   my ($file) = @_;
  304.   verb "reading $file";
  305.   local $/;            # Turn on slurp-mode.
  306.   my $f = new Autom4te::XFile "< $file";
  307.   my $contents = $f->getline;
  308.   $f->close;
  309.   return $contents;
  310. }
  311.  
  312.  
  313. 1; # for require
  314.  
  315. ### Setup "GNU" style for perl-mode and cperl-mode.
  316. ## Local Variables:
  317. ## perl-indent-level: 2
  318. ## perl-continued-statement-offset: 2
  319. ## perl-continued-brace-offset: 0
  320. ## perl-brace-offset: 0
  321. ## perl-brace-imaginary-offset: 0
  322. ## perl-label-offset: -2
  323. ## cperl-indent-level: 2
  324. ## cperl-brace-offset: 0
  325. ## cperl-continued-brace-offset: 0
  326. ## cperl-label-offset: -2
  327. ## cperl-extra-newline-before-brace: t
  328. ## cperl-merge-trailing-else: nil
  329. ## cperl-continued-statement-offset: 2
  330. ## End:
  331.